home *** CD-ROM | disk | FTP | other *** search
/ CICA 1993 April / CICA MS Windows - April 1993.iso / unzipped / programr / tp / tpwmi2 / diskd.pas < prev    next >
Pascal/Delphi Source File  |  1992-04-03  |  4KB  |  161 lines
  1. program DiskD;
  2.  
  3. {$R MemStat.RES}
  4.  
  5. uses WObjects, WinTypes, WinProcs, Strings, WinDOS, Frames;
  6.  
  7. type
  8.     TDiskDApp = object(TApplication)
  9.         procedure InitMainWindow; virtual;
  10.     end;
  11.  
  12.     PDiskDWindow = ^TDiskDWindow;
  13.     TDiskDWindow = object(TWindow)
  14.         function GetClassName: PChar; virtual;
  15.         procedure SetupWindow; virtual;
  16.         procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  17.         procedure Paint(PaintDC:HDC; var PaintInfo:TPaintStruct); virtual;
  18.         procedure WMDestroy(var Msg:TMessage); virtual wm_First+wm_Destroy;
  19.         procedure About;
  20.         procedure WMQueryOpen(var Msg:TMessage); virtual wm_First+wm_QueryOpen;
  21.         procedure WMSysCommand(var Msg:TMessage); virtual wm_First+wm_SysCommand;
  22.         procedure WMTimer(var Msg:TMessage); virtual wm_First+wm_Timer;
  23.     end;
  24.  
  25. var
  26.     R:TRect;
  27.     PctTxt:array[0..4] of Char;
  28.  
  29. const
  30.     sc_About=100;
  31.     sc_Options=101;
  32.  
  33. procedure TDiskDApp.InitMainWindow;
  34. begin
  35.     MainWindow := New(PDiskDWindow, Init(nil, 'Space on D:'));
  36. end;
  37.  
  38. function TDiskDWindow.GetClassName: PChar;
  39. begin
  40.     GetClassName := 'DiskD'
  41. end;
  42.  
  43. procedure TDiskDWindow.GetWindowClass(var AWndClass: TWndClass);
  44. begin
  45.     TWindow.GetWindowClass(AWndClass);
  46.     AWndClass.HIcon := 0; {This is a necessary line. It tells Windows to
  47.                                                  leave the iconized window blank, allowing a
  48.                                                  program to draw on it.}
  49. end;
  50.  
  51. procedure TDiskDWindow.SetupWindow;
  52. var ResMenu:HMenu;
  53.         T:longint;
  54. begin
  55.     TWindow.SetupWindow;
  56.     if SetTimer(HWindow,20,5000,nil)=0 then  {timer set for 1/2 second}
  57.     begin
  58.         MessageBox(HWindow,'Too many timers in use. Cannot load.',
  59.                              'DiskD Stats',mb_IconExclamation or mb_OK);
  60.         CloseWindow;
  61.     end;
  62.     UpdateWindow(HWindow);
  63.     ResMenu:=GetSystemMenu(HWindow,false);
  64.     DeleteMenu(ResMenu,sc_Restore,mf_ByCommand);
  65.     DeleteMenu(ResMenu,sc_Maximize,mf_ByCommand);
  66. {    AppendMenu(ResMenu,mf_String,0,nil);
  67.     AppendMenu(ResMenu,mf_String,sc_About,'&About Memory Stats...');}
  68.     SendMessage(HWindow,wm_Timer,1,0);
  69. end;
  70.  
  71. procedure TDiskDWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
  72. var TextMetrics:TTextMetric;
  73.         LogicFont:HFont;
  74.         size:integer;
  75.         wout:boolean;
  76. begin
  77.     with R do
  78.     begin
  79.         Right:=GetSystemMetrics(sm_CXIcon)+3;
  80.         Bottom:=GetSystemMetrics(sm_CYIcon)+3;
  81.         Left:=0;Top:=0;
  82.     end;
  83.     DrawBorderFrame(PaintDC,R,true);
  84.     size:=15;
  85.     wout:=true;
  86.     while wout do
  87.     begin
  88.         LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
  89.         SelectObject(PaintDC,LogicFont);
  90.         If Loword(GetTextExtent(PaintDC,'100%',4))<(R.right-2) then wout:=false
  91.         else
  92.             begin
  93.                 DeleteObject(LogicFont);
  94.                 size:=size-1;
  95.             end;
  96.     end;
  97.     SetBkMode(PaintDC,Transparent);
  98.     SetTextAlign(PaintDC,ta_Bottom);
  99.     SetTextColor(PaintDC,RGB(0,0,0));
  100.     GetTextMetrics(PaintDC,TextMetrics);
  101.     TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt,StrLen(PctTxt))))/2),
  102.         R.bottom-Round((R.bottom-TextMetrics.tmHeight-2)/2),PctTxt,StrLen(PctTxt));
  103.     DeleteObject(LogicFont);
  104. end;
  105.  
  106. procedure TDiskDWindow.WMTimer(var Msg:TMessage);
  107. var
  108.     wFree,wSize:word;
  109.     GDIPct,UserPct,dwInfo:longint;
  110.     PctTxtT:array[0..4] of char;
  111.     PctNum:string;
  112. begin
  113.     Str(Round(DiskFree(4)/DiskSize(4)*100),PctNum);
  114.     StrPCopy(PctTxtT,PctNum+'%');
  115.     if (StrPas(PctTxtT) <> StrPas(PctTxt)) or (Msg.wParam=1) then
  116.     begin
  117.         StrPCopy(PctTxt,PctTxtT);
  118.         InvalidateRect(HWindow,nil,false);
  119.         UpdateWindow(HWindow);
  120.     end;
  121. end;
  122.  
  123. procedure TDiskDWindow.WMQueryOpen(var Msg:TMessage);
  124. begin
  125.     Msg.Result:=0;
  126. end;
  127.  
  128. procedure TDiskDWindow.WMDestroy(var Msg:TMessage);
  129. begin
  130.     KillTimer(HWindow,20);
  131.     TWindow.WMDestroy(Msg);
  132. end;
  133.  
  134. procedure TDiskDWindow.WMSysCommand(var Msg:TMessage);
  135. begin
  136.     case Msg.wParam of
  137.         sc_About:
  138.                 About  {I was thinking about adding an Options... menu item.}
  139.         else             {That's why this unnecessary Case command is here.}
  140.             DefWndProc(Msg);
  141.     end;
  142. end;
  143.  
  144. procedure TDiskDWindow.About;
  145. var Dialog:TDialog;
  146. begin
  147.     Dialog.Init(@Self, 'About');
  148.     Dialog.Execute;
  149.     Dialog.Done;
  150. end;
  151.  
  152. var
  153.     DiskDApp: TDiskDApp;
  154.  
  155. begin
  156.     CmdShow:=sw_Minimize;
  157.     DiskDApp.Init('DiskDApp');
  158.     DiskDApp.Run;
  159.     DiskDApp.Done;
  160. end.
  161.